home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / describe.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  7KB  |  240 lines
  1. ;;; describe various objects
  2. ;;; version 1.0
  3. ;;; RJB May 92
  4.  
  5. (defmodule describe
  6.  
  7.   ((rename ((function-lambda-list fll)) eulisp0)
  8.    fn-docs)
  9.   ()
  10.  
  11.   ; first fix fll
  12.   (defgeneric function-lambda-list (fun))
  13.  
  14.   (defmethod function-lambda-list ((f <object>))
  15.     (fll f))
  16.  
  17.   (defmethod function-lambda-list ((gf <generic-function>))
  18.     (let ((meths (generic-function-methods gf)))
  19.       (if (atom meths)
  20.       "unknown"
  21.       (mkargs (length (method-signature (car meths)))))))
  22.  
  23.   (defmethod function-lambda-list ((c <continuation>))
  24.     '(a))
  25.  
  26.   (defun mkargs (n)
  27.     (if (= n 0) ()
  28.     (cons (vector-ref #(@ a b c d e f g h i j k l m n o
  29.                   p q r s t u v w x y z) n)
  30.           (mkargs (- n 1)))))
  31.  
  32.   (defgeneric describe (obj))
  33.  
  34.   (defmethod describe ((cl <class>))
  35.     (format t "The class ~a is an instance of ~a~%"
  36.         cl (class-of cl))
  37.     (format t "class precedence list: ~a~%"
  38.         (class-precedence-list cl))
  39.     (format t "direct superclasses:   ~a~%"
  40.         (class-direct-superclasses cl))
  41.     (format t "direct subclasses:     ~a~%"
  42.         (class-direct-subclasses cl))
  43.     (when (class-slot-descriptions cl)
  44.       (format t "direct slots~%------------~%")
  45.       (mapcar describe-slot
  46.           (class-slot-descriptions cl)))
  47. ;    (when (class-constructors cl)
  48. ;      (format t "------------~%")
  49. ;      (format t "class constructors:~%")
  50. ;      (mapcar print (class-constructors cl)))
  51.     t)
  52.  
  53.   (defmethod describe ((inst <object>))
  54.     (format t "~a is an instance of ~a~%"
  55.         inst (class-of inst))
  56.     (describe-slot-values (class-slot-descriptions (class-of inst))
  57.               inst)
  58.     t)    
  59.  
  60.   (defun describe-slot (sl)
  61.     (format t "slot name: ~a~%"
  62.         (slot-description-name sl))
  63.     (format t "position:  ~a~%"
  64.         (slot-description-position sl))
  65.     (format t "initarg:  ~a~%"
  66.         (slot-description-initarg sl)))
  67.  
  68.   (defun describe-slot-values (slotds inst)
  69.     (when slotds
  70.       (let ((name (slot-description-name (car slotds))))
  71.         (format t "slot ~a: ~a~%"
  72.             name
  73.             (protected-slot-value inst name))
  74.         (describe-slot-values (cdr slotds) inst))))
  75.  
  76.   (defun protected-slot-value (inst name)
  77.     (let/cc leave
  78.             (with-handler
  79.              (lambda (cond cont)
  80.                (leave "**Error---unreadable slot")
  81.            )
  82.              ((slot-description-slot-reader (find-slot-description (class-of inst) name)) inst))))
  83.  
  84.   (defmethod describe ((f <function>))
  85.     (call-next-method)
  86.     (format t "argument list: ~a~%" (function-lambda-list f))
  87.     t)
  88.  
  89.   (defmethod describe ((gf <generic-function>))
  90.     (call-next-method)
  91.     (format t "methods signatures:~%")
  92.     (mapcar (lambda (m)
  93.           (format t "~a~%" (method-signature m)))
  94.         (generic-function-methods gf))
  95.     t)
  96.  
  97.   (defmethod describe ((m <method>))
  98.     (call-next-method)
  99. ;    (format t "generic function: ~a~%" (method-generic-function m))      
  100.     (format t "signature: ~a~%" (method-signature m))
  101.     t)
  102.  
  103.   (defmethod describe ((th <thread>))
  104.     (call-next-method)
  105.     (format t "thread state: ~a~%" (thread-state th))
  106.     t)
  107.  
  108.   (defmethod describe ((sl <slot-description>))
  109.     (call-next-method)
  110.     (describe-slot sl)
  111.     t)
  112.  
  113.   ; semaphores
  114.  
  115.   ; now export 
  116.   (export describe)
  117.   
  118.   ;; show -- simple non-generic describe
  119.   (defun show (x) 
  120.     (format t "~a [~a]~%" x (class-of x))
  121.     (mapc (lambda (s)
  122.         (format t "~a: ~a~%" (slot-description-name s)
  123.             ((slot-description-slot-reader s) x)))
  124.       (class-slot-descriptions (class-of x))))
  125.  
  126.   (export show)
  127.  
  128.   (defun class-slots (cl)
  129.     (mapcar slot-description-name
  130.         (class-slot-descriptions cl)))
  131.  
  132.   (defun class-hierarchy ()
  133.     (do-class-hierarchy (list <object>) 0 t))
  134.   
  135.   (defun class-hierarchy-1 ()
  136.     (do-class-hierarchy (list <object>) 0 nil))
  137.  
  138.   (defun do-class-hierarchy (objlist depth flag)
  139.     (print-indent (car objlist) depth)
  140.     (if (class-slots (car objlist))
  141.     (when flag
  142.       (prin "slots: ")
  143.       (print-indent (class-slots (car objlist)) depth))
  144.         nil)
  145.     (if (class-direct-subclasses (car objlist))
  146.     (do-class-hierarchy (class-direct-subclasses (car objlist))
  147.                 (+ depth 4) flag)
  148.         nil)
  149.     (if (cdr objlist)
  150.     (do-class-hierarchy (cdr objlist) depth flag)
  151.         nil))
  152.  
  153.   (defun print-indent (obj depth)
  154.     (if (= depth 0)
  155.     (print obj)
  156.         (progn
  157.       (prin " ")
  158.       (print-indent obj (- depth 1)))))
  159.  
  160.   (export class-hierarchy class-hierarchy-1)
  161.  
  162.   ;; Additional method for printing bytefunctions
  163.   
  164.   (defmethod describe ((ebf <extended-bytefunction>))
  165.     (format t "~a is an instance of ~a~%" ebf (class-of ebf))
  166.     (format t "defined in: ~a.em~%" (car (extended-bytefunction-info ebf)))
  167.     (print "documentation:")
  168.     (print (bytefunction-info ebf))
  169.     t)
  170.  
  171.   (defmethod generic-prin ((ebf <extended-bytefunction>) stream)
  172.     (format stream "#<~a: ~a[~a.em] ~u>" 
  173.         (symbol-unbraced-name (class-name (class-of ebf) ))
  174.         (bytefunction-name ebf)
  175.         (bytefunction-location ebf)
  176.         ebf))
  177.   
  178.   (defun bytefunction-location (ebf)
  179.     (car (extended-bytefunction-info ebf)))
  180.  
  181.   (defun bytefunction-name (ebf)
  182.     (let ((info (extended-bytefunction-info ebf)))
  183.       (let ((file (find-doc-file (car info))))
  184.     (if (null file) "{unknown}"
  185.       (let ((name (read-name file (cdr info))))
  186.         (close file)
  187.         name)))))
  188.  
  189.   (defun bytefunction-info (ebf)
  190.     (let ((info (extended-bytefunction-info ebf)))
  191.       (let ((file (find-doc-file (car info))))
  192.     (if (null file) ""
  193.       (let ((junk (read-entry file (cdr info))))
  194.         (close file)
  195.         (cdr junk))))))
  196.  
  197.   (defun find-doc-file (name)
  198.     (let/cc out
  199.         (with-handler (lambda (cond cont)
  200.                 (out nil))
  201.               (path-open (make-search-path  "FEEL_OBJS_PATH"
  202.                             #\: ".")
  203.                      (format nil "~a.doc" name)))))
  204.     
  205.   (defun make-search-path (shell-var separator default)
  206.     (let ((sp (or (getenv shell-var) default))
  207.       (sp-length 0))
  208.       (if (null sp)
  209.       (list ".")
  210.     (labels (
  211.          (dissect-path (index previous-index index-pairs)
  212.             (if (= index sp-length)
  213.             (cons (cons previous-index (- index 1)) index-pairs)
  214.               (if (equal (string-ref sp index) separator)
  215.               (dissect-path
  216.                (+ index 1)
  217.                (+ index 1)
  218.                (cons (cons previous-index (- index 1)) index-pairs))
  219.             (dissect-path (+ index 1) previous-index index-pairs)))))
  220.         (setq sp-length (string-length sp))
  221.         (reverse
  222.          (mapcar (lambda (start-finish)
  223.                (substring sp (car start-finish) (cdr start-finish)))
  224.              (dissect-path 0 0 ())))))))
  225.  
  226.   (defun path-open (pathlist name . options)
  227.     (let/cc succeed
  228.         (mapc (lambda (path)
  229.             (let/cc fail
  230.                 (with-handler (lambda (a b) (fail ()))
  231.                       (succeed (apply open (format nil "~a/~a" path name) options)))))
  232.           pathlist)
  233.         (error
  234.          (format nil "path-open: cannot open stream for (~a) ~a" pathlist name)
  235.          <Internal-Error>)
  236.         nil))
  237.  
  238.  
  239. )
  240.